home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Toolbox classes / TEScroller < prev    next >
Encoding:
Text File  |  1995-12-13  |  10.0 KB  |  363 lines  |  [TEXT/MSET]
  1. \ Nov 95   JRF added EraseRect call to Draw: method to fix a caret problem
  2. \                when using outline highliting.
  3. \ 30May93 MRH optimized KEY: to only call fixPanRect: when necessary
  4.  
  5. \ 15May93 DBH removed noclip from CallTEScroll: per mrh.
  6.     \ Use selstart: and getpoint: in CARETLOC: .  Deleted CURRENTLINE: method.
  7.     \ Added lineEnd: method.
  8.     
  9. \ 17Jun93    mrh removed update: in setSelect: - don't need it
  10. \ Sept 93    mrh    revised for Control now being a View subclass
  11. \ May  94    mrh using LeftMargin instead of offsetting MainView.  Handling
  12. \                cursor change here instead of in TextEdit - our view system
  13. \                makes it easy.
  14.  
  15. need window+
  16. need TextEdit
  17.  
  18. 4    constant LeftMargin            \ White space at left of the text
  19. 20    constant BottomMargin        \ (was 40 JRF)  White space at the bottom
  20.  
  21. \ 0 value   ThisTE
  22.  
  23. \ false    value    chkScroll?
  24.  
  25. objptr  $TMP  class_is string+
  26.  
  27.  
  28. :class  TEScroller  super{ scroller }
  29.  
  30.     TextEdit    theTE 
  31.     rect        rPanRect        \ TE needs a rect, not a bigRect.  So we
  32.                                 \  mirror our PanRect here.
  33.  
  34.     bool        Wrap?            \ Nov95 JRF
  35.  
  36.  
  37. private         \ Housekeeping methods related to scrolling:
  38.  
  39. :m DoScroll:    \ ( dx dy -- )  This replaces PAN: in Scroller, except
  40.                 \        that dx and dy have their signs reversed
  41.                 \        (a pan down = a scroll up, etc.)
  42.                 
  43.     ^viewRect: mainView  call ClipRect
  44.     scroll: theTE  ;m
  45.  
  46.  
  47. :m PANRIGHT:  { dx \ hs -- }
  48.     get: theHscroll  -> hs
  49.     hs dx +  get: Hpan  >
  50.     IF  get: Hpan  hs -  -> dx  THEN
  51.     dx  0EXIT
  52.     hs dx +  dup  put: theHscroll  put: hpos
  53.     dx negate  0  doScroll: self  ;m
  54.  
  55. :m PANLEFT:  { dx \ hs -- }
  56.     get: theHscroll  -> hs   hs 0EXIT
  57.     hs dx -  0< IF  hs -> dx  THEN
  58.     hs dx -  dup  put: theHscroll  put: hpos
  59.     dx  0  doScroll: self  ;m
  60.  
  61. :m PANDOWN:  { dy \ vs -- }
  62.     get: theVscroll  -> vs
  63.     vs dy +  get: Vpan  >
  64.     IF  get: Vpan  vs -  -> dy  THEN
  65.     dy  0EXIT
  66.     vs dy +  dup  put: theVscroll  put: vpos
  67.     0  dy negate  doScroll: self  ;m
  68.  
  69. :m PANUP:  { dy \ vs -- }
  70.     get: theVscroll  -> vs   vs 0EXIT
  71.     vs dy - 0<  IF  vs -> dy  THEN
  72.     dy  0EXIT
  73.     vs dy -  dup  put: theVscroll  put: vpos
  74.     0  dy  doScroll: self  ;m
  75.  
  76.  
  77. :m HPAGE:  { \ left top rt bot -- #pixels }
  78.     getViewRect: mainView  -> bot  -> rt  -> top  -> left
  79.     rt left -  get: Hunit -  0 max  ;m
  80.  
  81. :m VPAGE:  { \ left top rt bot -- #pixels }
  82.     getViewRect: mainView  -> bot  -> rt  -> top  -> left
  83.     bot top -  get: Vunit -  0 max  ;m
  84.  
  85. public
  86.  
  87. :m WrapIt:
  88.     true put: Wrap?  ;m            \ Nov95 JRF
  89.  
  90. :m NoWrap:
  91.     false put: Wrap?  ;m        \ Nov95 JRF
  92.  
  93.  
  94. \ The messages 1right: etc. are public because they're late-bound to.
  95.  
  96. :m 1RIGHT:      get: Hunit  panRight: self    noClip  ;m
  97. :m 1LEFT:       get: Hunit  panLeft: self   noClip  ;m
  98. :m 1UP:             get: Vunit  panUp: self         noClip  ;m
  99. :m 1DOWN:       get: Vunit  panDown: self   noClip  ;m
  100.  
  101. :m PGRIGHT:     hPage: self  panRight: self     ;m
  102. :m PGLEFT:      hPage: self  panLeft: self      ;m
  103. :m PGUP:        vPage: self  panUp: self        ;m
  104. :m PGDOWN:      vPage: self  panDown: self      ;m
  105.  
  106.  
  107. :m VDRAG:  { \ dy vs -- }
  108.     get: theVscroll  -> vs
  109.     vs  get: Vpan  >
  110.     IF  get: Vpan  -> vs  THEN   \ Shouldn't really happen
  111.     vs  get: vpos -  -> dy   vs put: vpos
  112.     0 dy negate  doScroll: self  ;m
  113.  
  114.  
  115. :m HDRAG:  { \ dx hs -- }
  116.     get: theHscroll  -> hs
  117.     hs  get: Hpan  >
  118.     IF  get: Hpan  -> hs  THEN    \ Shouldn't really happen
  119.     hs  get: hpos -  -> dx   hs put: hpos
  120.     dx negate  0  doScroll: self  ;m
  121.  
  122.  
  123. :m ?SCROLL:  { x y \ l t r b -- }       \ If necessary, scrolls so that the
  124.                                          \ point (x, y) is in view.
  125.     ^viewRect: mainView  ->: tempRect
  126.     get: Hunit  get: Vunit  inset: tempRect    \ Trigger scrolling a bit before
  127.                                             \ the boundary
  128.     get: tempRect
  129.     -> b  -> r  -> t  -> l
  130.     y b > IF  y b -  panDown: self  THEN
  131.     t y > IF  t y -  panUp: self    THEN
  132.     x r > IF  x r -  panRight: self THEN
  133.     l x > IF  l x -  panLeft: self  THEN  ;m
  134.  
  135.  
  136. \ CoerceMainViewPanRect: is similar to CoercePanRect: mainView, except
  137. \ that we don't have child views to shift, but text to scroll instead.
  138.  
  139. :m CoerceMainViewPanRect:  { \ dx dy -- }
  140.     (coercePanRect): mainView  -> dy  -> dx
  141.     dx dy or  0EXIT
  142.     dx dy  doScroll: self
  143.     getPanRect: mainView  put: rPanRect  ;m
  144.  
  145.  
  146. :m FIXPANRECT: { \ x y adr -- }  \ Dec95 JRF revised to allow wrapping
  147.  
  148. \ Ensures PanRect = TE's dest rect, plus a margin at the bottom and the
  149. \ left.
  150.     handle: theTE @  -> adr
  151.     get: Wrap?
  152.     NIF
  153.         32766 getpoint: theTE -> y  -> x
  154.         y  adr 4+  w!            \ Adjust bottom of dest rect and
  155.         1600  adr 6 + w!        \ right coordinate if not wrapping
  156.  
  157.     ELSE            \ We can't be arbitrary here if wrapping
  158.  
  159.         adr 8 + size: rect drop 6 - adr 2 + w@ + adr 6 + w!   \ adjust rt dest
  160.         handle: theTE dup
  161.         call TeCalText        \ adjusts line ends so we can find new bottom,
  162.         @ -> adr            \ above call sometimes moves theTE, so
  163.                             \  dereference again
  164.         size: theTE
  165.         getpoint: theTE nip adr 4 + w!  \ Adjust bottom of dest rect
  166.     THEN
  167.     adr ->: rPanRect
  168.     getBotY: rPanRect  bottomMargin +  putBotY: rPanRect
  169.     getTopX: rPanRect    leftMargin -  putTopX: rPanRect
  170.     get:  rPanRect  putPanRect: mainView
  171.     coerceMainViewPanRect: self            \ Move it if it was out of kilter
  172.     setPanRanges: self  ;m                \ Fix scroll bars
  173.  
  174.  
  175. :m MOVED:                        \ Note: we MUSTN'T call moved: super !!
  176.     ^base  moved: view            \ but we must do the basic view stuff!
  177.     get: alive?  0EXIT
  178.     getViewRect: mainView  setViewRect: theTE
  179.     fixPanRect: self
  180.     ^viewRect: mainView  clear: rect
  181.     ( update: self )  ;m
  182.  
  183.  
  184. \ Clicking is a little bit complicated.  We can't handle clicking on the
  185. \ TE text via overriding CLICK: here, since the scroll bars are within
  186. \ our area as well.  We could override CLICK: in MainView, which would
  187. \ mean defining a different MView subclass, or we could just install a
  188. \ suitable click handler in each MainView object instantiated.  The latter
  189. \ is the easiest, so that's what we do.  Then MainView has to call back
  190. \ this TEScroller object, since MainView doesn't know anything about
  191. \ thisTE.  This sounds a little bit involved, but the code is very short,
  192. \ especially as a click on any Scroller (of which TEscroller is a subclass)
  193. \ puts its own address in ClickedScroller.  This makes it easy for MainView
  194. \ to send a message back.  The other nice thing is that we KNOW that this
  195. \ click handler will only be called when we want it - we don't need to filter
  196. \ out clicks on scroll bars or anywhere else.  MainView's click handler
  197. \ simply never sees them.
  198.  
  199.  
  200. :m AUTOSCROLL:          \ Called from DragProc.
  201.     get: theMouse  drop
  202.     ?scroll: self  ;m
  203.  
  204.  
  205. :proc  DRAGPROC         \ ( TEhandle newPoint -- )
  206.                        \ See, we CAN define a :proc word (or any other) in the
  207.                     \ middle of a class definition!
  208.     autoScroll: [ clickedScroller ]
  209.     word0 drop  w 1     \ We have to return a Pascal boolean TRUE!
  210.  
  211. ;proc
  212.  
  213.  
  214. :m MVCLICKED:    \ Called from MainView via its click handler (see just below).
  215.                 \ We just have to set theTE's dragproc and call its
  216.                 \ click: method.
  217.  
  218.     ['] dragproc  ptr: theTE 42 + !            \ Set drag proc in TE record  
  219.     click: theTE  ;m
  220.  
  221.  
  222. : DoClick        \ This word is installed as MainView's click handler.
  223.                 \ It will ONLY be called when there's a click on MainView
  224.                 \ - not for a scroll bar click.
  225.  
  226.     MVclicked: [ clickedScroller ]  ;
  227.  
  228.  
  229.  
  230. :m SIZE:    \ ( -- n )
  231.     size: theTE  ;m
  232.  
  233.  
  234. :m ENABLE:
  235.     enable: super 
  236.     activate: theTE ;m      
  237.  
  238. :m DISABLE:
  239.     disable: super
  240.     deactivate: theTE ;m    
  241.  
  242.  
  243. :m DRAW:
  244.     \ TE looks after clipping itself, so we don't need our default clipping.
  245.     \ It would cause problems anyway, since we use the grafport origin when
  246.     \ calling TE, while our default clipping uses view origin.  So we
  247.     \ disable our own clipping.
  248.     
  249.     false  put: setClip?
  250.     noClip            \ Experimentation shows this is definitely necessary!!
  251.     addr: viewRect dup call eraserect  update: theTE  ;m        
  252.                     \ Added EraseRect to fix a caret problem
  253.                     \ using outline hilite feature - Nov 95, JRF
  254.         
  255. :m SETSELECT:  { strt end -- }
  256.     pushPort  set: [ get: ^myWind ]
  257.     strt end  select: theTE 
  258. \    update: [ get: ^myWind ]
  259.     popPort  ;m
  260.  
  261.  
  262. :m CARETLOC:    \ ( -- x y )
  263.     selstart: theTE
  264.     getpoint: theTE  ;m
  265.  
  266. :m CARETINTOVIEW:    \ Scrolls if nec to get the insertion point visible
  267.     caretLoc: self  ?scroll: self
  268.     noClip  ;m                \ not quite sure why we need this, but we do!
  269.     
  270.  
  271. :m KEY:  { char -- }
  272.     noClip                        \ it seems we can sometimes be clipped out
  273.     char  key: theTE
  274.     selStart: theTE  selEnd: theTE <>
  275.     char 8 ( delete ) =        or
  276.     char RET =                or
  277.     get: Wrap?                or        \ Dec95 JRF
  278.     IF fixPanRect: self  THEN        \ If insertion/deletion may have
  279.                                     \  changed BoundsRect
  280.     caretIntoView: self                \ Scroll if necessary
  281. ;m
  282.  
  283. :m INSERT:  \ ( addr len )
  284.     noClip                        \ it seems we can sometimes be clipped out
  285.     insert: theTE
  286.     fixPanRect: self            \ insertion may have
  287.                                 \ changed BoundsRect
  288.     caretIntoView: self            \ Scroll if necessary
  289. ;m        
  290.  
  291. :m $INSERT: ( str -- ) { \ adr -- }
  292.     -> $tmp
  293.     get: $tmp  insert: self  ;m
  294.  
  295.  
  296. :m NEW:
  297.     new: super
  298.     get: viewRect  putPanRect: mainView        \ to start with, anyway
  299.     addr: viewRect ->: rPanRect
  300.     ['] doClick  setClick: mainview            \ Install mainview click hndlr
  301.     addr: rPanRect  ^viewRect: mainview  new: theTE
  302.     get: Wrap? IF WrapIt: theTE  ELSE  NoWrap: theTE  THEN        \ Dec95 JRF
  303.     fixPanRect: self
  304.     10 panLeft: self                 \ Ensure fully scrolled left initially
  305. ;m
  306.  
  307.  
  308. :m CUT:            cut: theTE  ;m    
  309.  
  310. :m COPY:        copy: theTE  ;m    
  311.  
  312. :m PASTE:        paste: theTE  ;m    
  313.  
  314. :m CLEAR:        clear: theTE  ;m
  315.  
  316. :m TextHandle:    textHandle: theTE  ;m
  317.  
  318.  
  319. :m GETSELECT:   \ ( -- addr len )       \ return hilited selection  
  320.         getselect: theTE ;m
  321.  
  322. \ getline: will return the entire line in which the cursor is currently in,
  323. \ regardless of where in the line the cursor is located.  No text need be
  324. \ selected.
  325.  
  326. :m GETLINE:     \ ( -- addr len )  
  327.         getline: theTE ;m
  328.  
  329. :m RELEASE:  
  330.         release: theTE ;m
  331.  
  332. :m HANDLE:      \ ( -- TEhndl )  
  333.         handle: theTE ;m
  334.  
  335. :m SELEND:      \ ( -- n )  
  336.         selend: theTE ;m
  337.         
  338. :m SELSTART:    \ ( -- n )  
  339.         selstart: theTE ;m
  340.  
  341. :m LINEEND:    \ ( -- n )    \ ** 
  342.     lineEnd: theTE ;m
  343.  
  344. :m IDLE:
  345.     idle: super
  346.     mouseHere?: mainView  IF  ibeamcurs  ELSE  arrowCurs  THEN
  347.     idle: theTE  ;m
  348.  
  349.  
  350. :m dump:
  351.     dump: theTE ;m
  352.  
  353.  
  354. :m CLASSINIT:    \ Note here that we inset the left margin of mainView by
  355.                 \    4 pixels - it looks better there than right on the
  356.                 \    edge.
  357.                 
  358. \    4 0 0 0  setBounds: mainView
  359.     classinit: super
  360.     16 dup put: Hunit  put: Vunit  ;m
  361.  
  362. ;class
  363.